perm filename RESTS.F4[NEW,LCS]12 blob sn#502556 filedate 1980-03-27 generic text, type T, neo UTF8
******* SUBRS  TAIL, FERMTA, REST, BREP, (SORT2), PNUM, LO2UP
	SUBROUTINE TAIL
	COMMON/ALF/INP(49),RMINI,RINV,RA,RX,RJX,NONO(19)
	COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
	1 /JCHAR/IXX,ISEMI,IBLA,IG
	DIMENSION ITAIL(16)
	DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
	1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
C--MISC. DATA FOR OTHER PLACES.	↓↓↓↓↓↓↓
	DATA IXX/'X'/,IG/'G'/,ISEMI/';'/,IBLA/' '/
	CALL CENTER(RJY)
	Q=-1.
	IF(RA)Q=1.
	IF(IPLT)GO TO 2
	ITAIL(1)=10
1	CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
	RETURN
2	P=Q
	IF(RMINI.NE.RSTJ2)P=P*.6
	ITAIL(1)=16
	CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(P),P)
C RA=-,STEM UP;  RA=+, STEM DOWN.
	GO TO 1
	END

	SUBROUTINE REST
	COMMON /STF/RSTFAC(8),RSTJ2/PLTR/IPLT,RHT,DIS
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	EQUIVALENCE(J5,JQ(3)),(R3,RJQ(1)),(R4,RJQ(2)),(R7,RJQ(5))
	1,(R6,RJQ(4)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8)),(J4,JQ(2))
	1,(R9,RJQ(7)),(J8,JQ(6))
	DIMENSION LRST(3),IRST(47),MR(2),MF(2)
	DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
	1 31,  23,100000051,100038,32,110017,200050044, 32 ,50026,
	1 100038,50044,100110017,70018,50017,50015,60011, 10016,
	1 18,  20,10022,30023, 50023, 70022,110017,
	1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
	1 30039, 50039, 70037, 70035, 50033, 30033,10035/
	1,LRST/1,10,33/,MR/18,8/,MF/15,40/
C  LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.

	L=J5
	IF(L.GT.1)L=1
	IF(L)L=-1
C  L>3 WHEN SEVERAL TAILS ON REST
	R10=RSTJ2
	IF(IABS(J4).LT.80)GO TO 2
C NEXT FOR MINI-RESTS
	RSTJ2=RSTJ2*.7
	J4=0
	R4=R4+2.
2	CALL CENTER(CENTR)
	RA=1.
	RB=R3
	IF(R8.GT.-3)GO TO 10
	CALL BREP
	GO TO 1
10	IF(J5.GT.-3)GO TO 9
C  -3 IN P5 = DOUBLE WHOLE REST.  R8=-4 OR -5 =REPEAT BAR SIGN.
CQQC  -3 IN P5 = DOUBLE WHOLE REST.  -4=REPEAT BAR SIGN.
CQQ	IF(J5.NE.-4)GO TO 10
CQQ	CALL BREP
CQQ	GO TO 1
CQQ10	J5=-5
	J5=-5
	RA=2.
	RB=RB-8*RSTJ2
C TO CENTER THE DOUBLE WHOLE REST.
9	IF(J5.GE.0)GO TO 5
	IF(J5.LT.-2)GO TO 12
C JUMP FOR DOUBLE WHOLE-REST
	B=R8
	C=R6
	D=R7
	X=R4
	K=-J5
	J8=0
	R8=0
	R6=0
	R7=0
	JA=3
	J5=8
CC	A=4.12
	IF(K.EQ.2)R4=R4+1.05
CC	R4=R4+A
	CEN=CENTR
	CALL CLEFS
C GO DRAW HALF OR WHOLE REST, THEN GET BACK PARAMS.
	CENTR=CEN
	J5=-K
	R8=B
	R4=X
	R6=C
	R7=D
	GO TO 11
12  	CENTR=CENTR+9.4*R10
C  CENTERS WHOLE REST
5	CALL JDRAW(IRST(LRST(L+2)),RB,CENTR,RSTJ2,RA,1.)
	IF(J5.GT.-3)GO TO 4
	J5=J5+1
	CENTR=CENTR-3.133*R10
	GO TO 5
4	IF(J5.GE.0)GO TO 6
CHECK FOR NEED OF LEDGER LINES (1/2 AND WHOLE RESTS)(NOT FOR DBLS).
11	RA=5
	RB=-5
  	CENTR=CENTR+29*RSTJ2
	IF(J5.EQ.-1)GO TO 8
	CENTR=CENTR+14*RSTJ2
CC	CENTR=CENTR+5*RSTJ2
	RA=3
	RB=-7
C THESE FOR WHOLE RESTS.  ABOVE FOR 1/2.
8	IF(R4.GE.RA)GO TO 7
	IF(R4.GT.RB)GO TO 6
7	IF(R9.NE.0)GO TO 6
C  P9≠0 SUPRESSES LEDGER LINE.
	RA=R3-7*RSTJ2
	RB=R3+25*RSTJ2
CC	RB=R3+22*RSTJ2
	CALL LINX(RA,CENTR,RB,CENTR)

6	IF(IPLT.GE.0)GO TO 1
	IF(J5)GO TO 1
	L=L+1
	CALL FILLMS(MR(L),IRST(MF(L)),R3,CENTR,1.,1.)
C  WHY GO THROUGH NOTWRT??
1	IF(R8.EQ.0)RETURN
C  TO PUT NUM OVER REST - MULTIPLE BARS.(R8=-1 =NO NUM. OVER WHOLE RST)
	R4=R4+10.6
C HEIGHT ??
	IF(IPLT)GO TO 3
	R6=5.96*R6
C  USE PARAM 6 TO CHANGE SIZE OF CENTERING AID LINE.
	IF(R6.EQ.0)R6=55.
	CALL LINX(R3-R6,CENTR,R3+R6+16.0*RSTJ2,CENTR)
C  HORIZ. LINE FOR CENTERING ON DPY ONLY.  WILL NOT PRINT!
C  NEXT IS J3 
3	JQ(1)=ROFF(R3+8.*RSTJ2)
	R5=R8
	R6=1.5
C  NUMBER SIZE
	R8=0
C  ↑↑↑↑↑ ALL THIS BECAUSE OF PARAM NUMS IN MAKNUM AND NOTWRT
	R7=0
C  FOR BDR40 FONT
	IF(R5.GE.1.)CALL MAKNUM(R5)
	J5=0
	R7=0
C  ↑↑↑↑↑ NEEDED??
	END

C  READS DATA 
C  FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
	SUBROUTINE BREP
CX	DIMENSION IREP(35)
C	COMMON R2,JA,CENTR,J2,R3,RJQ(39) /STF/RSTFAC(8),RSTJ2
	COMMON R2,JA,C,J,R3,R4,R5,R6,R7,RJQ(16),RA,J5 
CX	DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
CX	1,30015, 40015, 320043,100020037, 30038, 40038, 50037
CX	1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
CX	1,100270022,280021,290021,300022,300023,290024,280024,270023
CX	1,270022, 300022, 270023, 290023/
C	CALL CENTER(R)
C	CALL JDRAW(IREP,R3,R,RSTJ2,1.,1.)
	RA=R6
	JA=3
	J5=39
	R6=3.3333333
	R7=R6
	CALL CLEFS
	R6=RA
	END

	SUBROUTINE FERMTA
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
	1 /ALF/INP(49),RMINI,RINV,NO(22)
	EQUIVALENCE(J5,JQ(3)),(R4,RJQ(2)),(R7,RJQ(5)),(ISTEM,JQ(20))
	1,(R6,RJQ(4)),(R8,RJQ(6)),(R3,RJQ(1))
	1,(R9,RJQ(7)),(RA,JQ(4)),(RX4,JQ(19))
	DIMENSION JFERM(46)
	DATA JFERM/24,310020003,10010010,20015,60017,120017,160015,
	1 190010,200003,170010,150012,110014,70014,30012,10010,
	1 10020003,100070007,80008,100008,110007,110006,100005,80005
	1 ,70006,70007,20,100081006, 80012,  90012,  91006, 110030002,
	1 30008,70002,130008,170002, 200005, 200170002,141001,100005,
	1 130008,170002, 100070002, 41001, 5, 30008, 70002/

	IF(J5.EQ.25)GO TO 9
	IF(J5.EQ.26)GO TO 6
	IF(J5.LT.21)GO TO 6
C NEXT FOR MUSICA FICTA, 1,2,3=FLT,#,NAT. (IN CLEFB.DMD)
C J5=22=1(FLT), =23=#, =24=NAT.***** 27,28,29 STILL OPEN ********
7	J5=J5-12
	R7=0
	R6=.42
C  R6 (SIZE) COULD BE CHANGED ****
	R4=RX4+1.8
	IF(ISTEM.EQ.1)R4=R4+5  
	IF(R4.LT.11)R4=11
	R3=R3+15*RSTJ2
8	R8=0
	R9=0
	CALL CLEFS
	RETURN
C  NEXT FOR HEAVY WEDGE ACCENT
9	J5=44
C  TO BE FOUND IN 'CLEF4.DMD'
	RA=1.8
	IF(ISTEM.EQ.1)R7=-1
C 2= STEM DOWN
 	IF(R7)RA=-7.7
	R4=RX4+RA
	R6=1
	GO TO 8
6	IF(RINV.LT.17)GO TO 1
	JFERM(30)=16
	JFERM(36)=210005
	IF(RINV.NE.17)GO TO 2
	JFERM(30)=91006
	J=26
	GO TO 4
2	JFERM(30)=16
C  FOR INVERTED MORDANT
	J=30
4	RINV=1.
	GO TO 3
1	J=1
3	CALL JDRAW(JFERM(J),R3,CENTR,RMINI,1.,RINV)
	IF(IPLT.GE.0)RETURN
	IF(J.EQ.1)GO TO 5
	J=36
	JFERM(36)=10
5	RA=RSTJ2
	RSTJ2=1
	CALL FILLMS(JFERM(J),JFERM(J+1),R3,CENTR,RMINI,RMINI*RINV)
	RSTJ2=RA
C  BECAUSE FILLMS MULTS RMINI*RSTJ2.
	END

	SUBROUTINE PNUM
	INTEGER XAC
	COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,RJQ(16),J3,J4,J5,J6,J7,
	1 J10J,IPUNC,DONT,RXX,RX,JQ(10) /STF/RSTFAC(0/7),RSTJ2
	1 /PLTR/IPLT,RHT,DIS,XDIS
	DIMENSION NUMQ(44),RNUMS(341)
	COMMON/DAT/RACNT(69),RDOT(17),XAC(7),RNOTE(22),RACCI(22),NACCI(3)
C  ACCENTS BEGIN > ∧ DNBOW UPBOW  1ST NUM=END PT OF EACH ITEM
	DATA RACNT/4.,1000.006,17.001,0.104,  8.,1003.0, 7.014, 11.0
	1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,31.,
	1 1003.001, 4.003, 6.004, 8.004,10.003,11.001, 11.101,
	1 10.103,8.104,6.104,4.103, 3.101, 3.001,
	1 36.0,1000.0,14.0,1007.007,7.107, 47.0,1012.01,11.006,9.003
	1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 56.0,
	1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008,
	1 69.,1106.104, 0.002, 6.104, 12.002, 18.104, 24.002, 24.003,
	1 18.103, 12.003, 6.103, 0.003, 106.103/
C RNOTE 1-7=DPY WHITE NOTE, 8-12=DIAMOND, 13-16=X, 17-22=DPY BLACK NOTE
C DIAMOND AND X SHIFTED TO RIGHT BECAUSE USED 3 TIMES TO THICKEN.
C ORDER=WHITE, X, DIAMOND, BLACK
	DATA RNOTE/ 1000., 5.007, 11.007, 16., 11.107, 5.107, 0.0,
     1 1001.0, 8.007, 15.0, 8.107, 1.,    1001.107, 15.007,
     1 1015.107,1.007,  1000.003,4.107,6.007,9.107,11.007,14.103/
	DATA RDOT/1000.101, .102, 1.103, 2.103, 3.102, 3.101, 2., 1.,
	1 .101, 2.103, 2., .102, 3.102, 1., 1.103, 3.101, .102/
	1 ,XAC/9,14,18,32,37,48,57/
C   ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
	DATA RACCI/6.0,1115.003, 110.007, 106.001,
     1 115.109, 115.021, 15.0, 1104.104, 118.108,
     1 1108.113, 108.016,  1104.008, 118.004,
     1 1114.014, 114.115, 22.0,1106.117, 106.007, 114.004
     1, 1114.018, 114.107, 106.104/
     1 ,NACCI/1,7,16/
	DATA
     1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
     1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
     1,250,256,261,266,  271,282,285,293,298,314,330,335/
      DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
     1 104.015, 107.01,107.102, 104.107, 3.107,
     1 14.0, 1105.011, 101.015, 101.107, 22.0,
     1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
     1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
     1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
     1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
     1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
     1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
     1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
     1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
     1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
     1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
     1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
     1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
     1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
     1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
     1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
C   THE NEXT IS FOR 'F' TO 'P'
C   1 NUM NOT NEEDED IN 'G'  ALSO IN RNOTE (1/2 NOTE).
      DATA (RNUMS(K),K=132,199)/
     1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0, 
     1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104, 
     1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
     1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
     1 1103.107, 103.015, 1106.015, 0.015,
     1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015, 
     1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
     1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
     1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
     1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/ 
C   'Q' TO ')'
      DATA(RNUMS(K),K=200,341)/
     1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
     1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
     1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
     1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
     1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
     1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
     1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
     1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
     1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
     1 281.0, 1105.102, 105.105,103.105,104.102,104.105,105.102,103.102,
     1103.108, 106.112, 1106.112, 284., 1110.003, 2.003, 292., 1105.102,
     1 105.105,104.102,104.105,103.102,103.105,105.102,297.0,1110.007,
     1 2.007, 1110.0, 2.0, 313.0, 1102.015, 104.013, 106.010,
     1 107.006,107.002,106.102,104.105,102.107, 104.104,105.102,106.002
     1 ,106.006,105.01,104.012,102.015, 329.0,1106.015,104.013,
     1 102.01 ,101.006,101.002,102.102,104.105,106.107, 104.104,103.102
     1 ,102.002,102.006,103.01,104.012,106.015,  334.0,1110.003,
     1 2.003, 1104.009, 104.103,  341.0,1110.004, 2.004, 1101.009,
     1 107.101, 1101.101, 107.009/
C  3RD ITEM IN 19400 NOT NEEDED 12/73
C  1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS

	CALL CENTX
	J10J=J5
	CALL NOZERO(R6)
	SIZ=R6*RSTJ2
	JTH=0
	IPUNC=0
	IF(J10J.LT.44)GO TO 1
	IPUNC=J10J
	IF(J10J.EQ.44)J10J=38
	IF(J10J.GE.45)J10J=36
	IF(J5.NE.46)GO TO 451
	RXX=4
	CALL RJBX(-RXX)
	RX=16
	CENTR=CENTR+RX*SIZ
1	IF(IPLT.GE.0)GO TO 451
	IF(J10J.EQ.37)GO TO 2  
	IF(J10J.EQ.39)GO TO 2
	IF(J10J.NE.42)GO TO 451
2	JTH=-2
451	IX=NUMQ(J10J+1)
C  IX=END # OF ITEM
C  IX+1=1ST PART OF ITEM
CCCC	IF(SIZ.LE.1.)CENTR=CENTR+(1.-SIZ)/.45
C ABOVE TO COMPENSATE FOR POOR VERTICAL POSITION OF FONTS (I THINK)
3     CALL RDRAW(IX+1,RNUMS(IX),RNUMS,SIZ,R3,CENTR+RSTJ2*3.,SIZ)
	IF(JTH.EQ.0)GO TO 4
	IF(J10J.GE.42)R3=R3+XDIS
	CENTR=CENTR+XDIS
	JTH=JTH+1
C  THIS PLOTS TRIPLE THICKNESS FOR - = + /
	GO TO 3
4	IF(IPUNC.EQ.0)RETURN
	IF(IPUNC.NE.46)GO TO 351
	CALL RJBX(SIZ*2.*RXX)
C  FOR "
651	IPUNC=0
	GO TO 451
351	RXX=11
C FOR : AND ;
	CENTR=CENTR+RXX*SIZ
	J10J=38
	GO TO 651
	END

	SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE TO UPPER CASE.
	J=J.AND..NOT.((J/2).AND."201004020100)
	END